home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
spool100.zip
/
SPOOLER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-04-21
|
12KB
|
405 lines
{ =============================================================================
SPOOLER ver. 1.0 del 21/04/90
Paolo Ruggieri - Genova
Una unit di PUBBLICO DOMINIO per accedere
ai servizi di PRINT.COM (spooler MS-DOS)
dai programmi in TurboPascal 4.0 o successivi.
Per commenti, suggerimenti e segnalazioni di bugs sono raggiungibile
via modem presso:
Utente MC4479 su MC-Link (300/1200/2400 baud, 8-N-1
06-4510211/4513182/4180440
NUA Itapac 26500140)
o attraverso l'area (echo Italia) TurboPascal presso
vari BBS della rete Fido.
============================================================================= }
{$R-,S-,V-}
unit Spooler;
interface
uses Dos;
const MAX_ENTRY_LEN = 63; { Massima lunghezza path del file da stampare }
MAX_SPOOLER_ENTRY = 32; { Numero masssimo di files in coda }
MIN_DOS_VERSION = $0300; { Minima versione Dos richiesta. }
SPOOLER_INSTALLED = $FF;
SPOOLER_NOT_INSTALLED = $00;
SPOOLER_CANNOT_BE_INSTALLED = $01;
QUEUE_FULL = $08;
type EntryType = string[MAX_ENTRY_LEN];
QueueType = array[1..MAX_SPOOLER_ENTRY] of EntryType;
var SpoolerResult : word;
{ ===================== FUNZIONI e PROCEDURE disponibili ==================== }
function SpoolerStatus : word;
procedure SubmitFileS(WildCString : EntryType; var Queue : QueueType);
procedure CancelFiles(WildCString : EntryType);
procedure CancelAllFiles;
procedure ListQueue(var Queue : QueueType);
{ CancelFiles e CancelAllFiles non eliminano i files da disco ma dalla coda }
{ =========================================================================== }
implementation
const NUL = #0;
MAX_ASCIIZ_LEN = 64;
type ASCIIZType = array[1..MAX_ASCIIZ_LEN] of char;
ASCIIZQueueType = array[1..MAX_SPOOLER_ENTRY] of ASCIIZType;
SubmitPacketType = record
LevelCode : byte;
FileStringAddr : pointer;
end;
cset = set of char;
{$IFDEF VER40}
PathStr = string[79];
{$ENDIF}
var regs : Registers;
HeapFSave : pointer;
{$IFDEF VER40}
DosVersion : word;
{$ENDIF}
{ -----------------------------------------------------------------------------
InitializeRegisters - inizializza a zero il record regs
(l'ho introdotta in seguito ad alcuni problemi in SubmitFile)
----------------------------------------------------------------------------- }
procedure InitializeRegisters;
begin
FillChar(regs,SizeOf(regs),NUL);
end;
{ -----------------------------------------------------------------------------
CarryFlag - ritorna true se il carry flag e` settato
----------------------------------------------------------------------------- }
function CarryFlag : boolean;
begin
if ((regs.flags and FCarry) = FCarry) then CarryFlag := true
else CarryFlag := false;
end;
{ -----------------------------------------------------------------------------
Str_to_ASCIIZ - converte una stringa TP in una stringa ASCIIZ
----------------------------------------------------------------------------- }
procedure Str_to_ASCIIZ(StrTP : EntryType; var ASCIIZ : ASCIIZType);
var i : byte;
begin
for i:=1 to length(StrTP) do ASCIIZ[i] := StrTP[i];
ASCIIZ[i+1] := NUL;
end;
{ -----------------------------------------------------------------------------
ASCIIZ_to_Str - converte una stringa ASCIIZ in una stringa TP
----------------------------------------------------------------------------- }
procedure ASCIIZ_to_Str(ASCIIZ : ASCIIZType; var StrTP : EntryType);
var i : byte;
begin
i := 1;
StrTP := '';
while (ASCIIZ[i]<>NUL) do
begin
StrTP := StrTP + ASCIIZ[i];
inc(i)
end;
end;
{ -----------------------------------------------------------------------------
Last - restituisce la posizione dell'ultima occorenza di un carattere
di un set
----------------------------------------------------------------------------- }
function Last(s : string; c : cset) : byte;
var i,
p : byte;
begin
p := 0;
for i:=length(s) downto 1 do if ((s[i] in c) and (p=0)) then p := i;
Last := p;
end;
{$IFDEF VER40}
{ -----------------------------------------------------------------------------
FExpand - espande un path in un nome file pienamente qualificato
----------------------------------------------------------------------------- }
function FExpand(path : PathStr) : PathStr;
var i : byte;
p,
fn,
cp : PathStr;
begin
{$I-}
GetDir(0,cp); if (IOResult<>0) then
begin
FExpand := '';
exit;
end;
i := Last(path,[':','\']);
p := copy(path,1,i);
fn := copy(path,i+1,length(path)-length(p));
if (p[length(p)]='\') then p[0] := chr(ord(p[0])-1);
p := '';
ChDir(p); if (IOResult=0) then
begin
GetDir(0,p);
if (IOResult=0) then p := p + '\';
end;
ChDir(cp);
{$I+}
FExpand := p + fn;
end;
{$ENDIF}
{ -----------------------------------------------------------------------------
SpoolerStatus - controlla se PRINT e` installato
Ritorna: SPOOLER_INSTALLED se e` INSTALLATO
SPOOLER_NOT_INSTALLED se NON e` INSTALLATO e
puo` essere installato
SPOOLER_CANNOT_BE_INSTALLED se NON e` INSTALLATO e
NON PUO` essere installato
----------------------------------------------------------------------------- }
function SpoolerStatus : word;
begin
if (DosVersion<MIN_DOS_VERSION) then
begin
SpoolerResult := SPOOLER_CANNOT_BE_INSTALLED;
SpoolerStatus := SpoolerResult;
exit;
end;
InitializeRegisters;
regs.ax := $0100;
Intr($2F,regs);
if (regs.al=SPOOLER_INSTALLED) then SpoolerResult := 0
else SpoolerResult := regs.al;
SpoolerStatus := regs.al;
end;
{ -----------------------------------------------------------------------------
SubmitFile - accoda FileString (singolo file) per la stampa
Simula: PRINT FileString [/P]
----------------------------------------------------------------------------- }
procedure SubmitFile(FileString : EntryType);
var SubmitPacket : SubmitPacketType;
ASCIIZ : ASCIIZType;
begin
if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
Str_to_ASCIIZ(FExpand(FileString),ASCIIZ);
SubmitPacket.LevelCode := 0;
SubmitPacket.FileStringAddr := addr(ASCIIZ);
InitializeRegisters;
regs.ax := $0101;
regs.ds := Seg(SubmitPacket);
regs.dx := Ofs(SubmitPacket);
Intr($2F,regs);
if CarryFlag then SpoolerResult := regs.ax
else SpoolerResult := 0;
end;
{ -----------------------------------------------------------------------------
SubmitFileS - accoda per la stampa uno o piu` files identificati
da WildCString (puo` contenere '?' e '*')
Simula: PRINT WildCString [/P]
----------------------------------------------------------------------------- }
procedure SubmitFileS(WildCString : EntryType; var Queue : QueueType);
var SearchInfo : SearchRec;
dir : PathStr;
FileString : EntryType;
i : byte;
begin
FillChar(Queue,SizeOf(Queue),NUL);
dir := copy(WildCString,1,Last(WildCString,[':','\']));
i := 0;
FindFirst(WildCString,Archive,SearchInfo);
while (DosError=0) do
begin
FileString := dir + SearchInfo.Name;
SubmitFile(FileString);
if (SpoolerResult<>0) then exit;
inc(i);
Queue[i] := FileString;
FindNext(SearchInfo);
end;
SpoolerResult := 0;
end;
{ -----------------------------------------------------------------------------
CancelFiles - toglie dalla coda uno o piu` files identificati
da WildCString (puo` contenere '?' e '*')
Simula: PRINT WildCString [/C]
(anche se PRINT /C non supporta le Wild Cards)
----------------------------------------------------------------------------- }
procedure CancelFiles(WildCString : EntryType);
var ASCIIZ : ASCIIZType;
SStatus : word;
begin
if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
Str_to_ASCIIZ(FExpand(WildCString),ASCIIZ);
InitializeRegisters;
regs.ax := $0102;
regs.ds := Seg(ASCIIZ);
regs.dx := Ofs(ASCIIZ);
Intr($2F,regs);
if CarryFlag then SpoolerResult := regs.ax
else SpoolerResult := 0;
end;
{ -----------------------------------------------------------------------------
CancelAllFiles - toglie dalla coda tutti i files
Simula: PRINT /T
----------------------------------------------------------------------------- }
procedure CancelAllFiles;
begin
if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
InitializeRegisters;
regs.ax := $0103;
Intr($2F,regs);
if CarryFlag then SpoolerResult := regs.ax
else SpoolerResult := 0;
end;
{ -----------------------------------------------------------------------------
HeapFunc - richiamata dallo Heap Manager se si verifica un errore di
allocazione; ritorna 1 cosi` New ritorna nil se non e` possibile
allocare la memoria richesta
----------------------------------------------------------------------------- }
{$F+}
function HeapFunc(dim : word) : integer;
begin
HeapFunc := 1;
end;
{$F-}
{ -----------------------------------------------------------------------------
ListQueue - restituisce la lista dei files in stampa (il 1^)
e in coda (gli altri)
Simula: PRINT
----------------------------------------------------------------------------- }
procedure ListQueue(var Queue : QueueType);
var ASCIIZ : ^ASCIIZQueueType;
i : byte;
begin
if (SpoolerStatus<>SPOOLER_INSTALLED) then exit;
InitializeRegisters;
FillChar(Queue,SizeOf(Queue),NUL);
HeapFSave := HeapError;
HeapError := @HeapFunc;
new(ASCIIZ);
HeapError := HeapFSave;
if (ASCIIZ=nil) then exit;
regs.ax := $0104;
Intr($2F,regs);
if CarryFlag then begin
SpoolerResult := regs.ax;
exit;
end
else SpoolerResult := 0;
move(ptr(regs.ds,regs.si)^,ASCIIZ^,sizeof(ASCIIZ^));
InitializeRegisters;
regs.ax := $0105;
Intr($2F,regs);
if CarryFlag then begin
SpoolerResult := regs.ax;
exit;
end
else SpoolerResult := 0;
i := 0;
repeat
inc(i);
ASCIIZ_to_Str(ASCIIZ^[i],Queue[i]);
until ((ASCIIZ^[i]=NUL) or (i=MAX_SPOOLER_ENTRY));
dispose(ASCIIZ);
end;
{ -----------------------------------------------------------------------------
SPOOLER UNIT - inizializzazione
----------------------------------------------------------------------------- }
begin
InitializeRegisters;
SpoolerResult := 0;
{$IFDEF VER40}
regs.ax := $3000;
MsDos(regs);
if (regs.al=0) then DosVersion := $0100
else DosVersion := regs.ax;
{$ENDIF}
end.